Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue53/Alfresco/AASimAnn.pas

Pascal/Delphi Source File | 1999-11-27 | 22.7 KB | 738 lines

{*********************************************************}
{* AASimAnn                                              *}
{* Copyright (c) Julian M Bucknall 1998-1999             *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco simulated annealing unit          *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AASimAnn;

interface

uses
  SysUtils,
  Classes;

{===Classes for the traveling salesman problem===}
type
  TaaCity = class {a city object}
    private
      FX : double;
      FY : double;
    protected
    public
      constructor Create(aX, aY : double);
        {-create a city with given coordinates}
      constructor CreateRandom;
        {-create a city with random coordinates in the range [0..100)}

      function Distance(aCity : TaaCity) : double;
        {-calculate the distance to another city}

      property X : double read FX;
        {-X coordinate}
      property Y : double read FY;
        {-Y coordinate}
  end;

  TaaTour = class {a tour of cities}
    private
      FList : TList;
      FDistance : double;
    protected
      function GetCity(aIndex : integer) : TaaCity;
      function GetCount : integer;
      function GetDistance : double;

      procedure Reverse(aStartInx, aEndInx : integer);
    public
      constructor Create;
        {-create a tour}
      destructor Destroy; override;
        {-destroy the tour}

      procedure AddCity(aCity : TaaCity);
        {-append a city to the tour}
      procedure Assign(aTour : TaaTour);
        {-copy the given tour to ours}
      procedure LoadFromFile(aName : string);
        {-load a tour from a file}

      function GetPossibleChange(var aUseRelocate : boolean;
                                 var aStartInx    : integer;
                                 var aEndInx      : integer;
                                 var aToInx       : integer) : double;
        {-generate a possible change and its difference in distance;
          aUseRelocate will be true if the change requires a
          relocation of a range of cities, false if the range is to be
          reversed}
      procedure ApplyChange(aUseRelocate : boolean;
                            aStartInx    : integer;
                            aEndInx      : integer;
                            aToInx       : integer;
                            aDeltaDist   : double);
        {-apply a change calculated by GetPossibleChange}

      property City[aIndex : integer] : TaaCity
                  read GetCity; default;
        {-the cities in the tour as an array}
      property Count : integer read GetCount;
        {-the number of cities in the tour}
      property Distance : double read GetDistance;
        {-the total distance of the tour}
  end;


{===Classes for the knapsack problem===}
type
  TaaArticle = class {an article with value and size}
    private
      FValue : double;
      FSize  : double;
    protected
    public
      constructor Create(aValue, aSize : double);
        {-create an article with given attributes}
      constructor CreateRandom;
        {-create an article with random attributes}

      property Value : double read FValue;
        {-value}
      property Size : double read FSize;
        {-size}
  end;

  TaaKnapsack = class {a knapsack of articles}
    private
      FList     : TList;
      FValue    : double;
      FFitCount : integer;
      FFitSize  : double;
      FSize     : double;
    protected
      function GetArticle(aIndex : integer) : TaaArticle;
      function GetCount : integer;
      function GetValue : double;
    public
      constructor Create(aSize : double);
        {-create a knapsack of a certain size}
      destructor Destroy; override;
        {-destroy the knapsack}

      procedure AddArticle(aArticle : TaaArticle);
        {-append a possible article to the knapsack}
      procedure Assign(aKnapsack : TaaKnapsack);
        {-copy the given knapsack to ours}
      procedure LoadFromFile(aName : string);
        {-load a knapsack from a file}

      procedure GenerateChange;
        {-randomly generate a possible change}

      property Article[aIndex : integer] : TaaArticle
                  read GetArticle; default;
        {-the articles in the knapsack as an array}
      property Count : integer read GetCount;
        {-the number of possible articles in the knapsack}
      property Value : double read GetValue;
        {-the total value of the articles that fit in the knapsack}
      property FitCount : integer read FFitCount;
        {-the number of articles that fit in the knapsack}
      property FitSize : double read FFitSize;
        {-the total size of articles that fit in the knapsack}
      property Size : double read FSize;
        {-the actual size of the knapsack}
  end;



procedure TravelingSalesman(aCityCount : integer;
                            aLog       : TStream);
  {-solve a travelling salesman problem with aCityCount cities,
    randomly placed, writing the details to the stream aLog}

procedure SolveKnapsackProblem(aArticleCount : integer;
                               aLog          : TStream);
  {-solve a knapsack problem with aArticleCount articles,
    randomly generated, writing the details to the stream aLog}

implementation

{===TaaCity==========================================================}
constructor TaaCity.Create(aX, aY : double);
begin
  inherited Create;
  FX := aX;
  FY := aY;
end;
{--------}
constructor TaaCity.CreateRandom;
begin
  inherited Create;
  FX := Random * 100;
  FY := Random * 100;
end;
{--------}
function TaaCity.Distance(aCity : TaaCity) : double;
begin
  Result := Sqrt(Sqr(X - aCity.X) + Sqr(Y - aCity.Y));
end;
{====================================================================}


{===TaaTour==========================================================}
constructor TaaTour.Create;
begin
  inherited Create;
  FList := TList.Create;
end;
{--------}
destructor TaaTour.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaTour.AddCity(aCity : TaaCity);
begin
  FList.Add(aCity);
end;
{--------}
procedure TaaTour.ApplyChange(aUseRelocate : boolean;
                              aStartInx    : integer;
                              aEndInx      : integer;
                              aToInx       : integer;
                              aDeltaDist   : double);
begin
  if aUseRelocate then begin
    if (aToInx < aStartInx) then begin
      Reverse(aToInx, aStartInx-1);
      Reverse(aStartInx, aEndInx);
      Reverse(aToInx, aEndInx);
    end
    else begin
      Reverse(aStartInx, aEndInx);
      Reverse(aEndInx+1, aToInx-1);
      Reverse(aStartInx, aToInx-1);
    end;
  end
  else begin
    Reverse(aStartInx, aEndInx);
  end;
  FDistance := Distance + aDeltaDist;
end;
{--------}
procedure TaaTour.Assign(aTour : TaaTour);
var
  i : integer;
begin
  if (FList.Count = aTour.FList.Count) then begin
    for i := 0 to pred(aTour.Count) do
      FList[i] := aTour.FList[i];
  end
  else begin
    FList.Clear;
    for i := 0 to pred(aTour.Count) do begin
      FList.Add(aTour[i]);
    end;
  end;
  FDistance := aTour.Distance;
end;
{--------}
function TaaTour.GetCity(aIndex : integer) : TaaCity;
begin
  Result := FList[aIndex];
end;
{--------}
function TaaTour.GetCount : integer;
begin
  Result := FList.Count;
end;
{--------}
function TaaTour.GetDistance : double;
var
  i : integer;
begin
  if (FDistance <= 0.0) then begin
    FDistance := 0.0;
    for i := 0 to (FList.Count - 2) do
      FDistance := FDistance + City[i].Distance(City[i+1]);
    FDistance := FDistance + City[0].Distance(City[pred(FList.Count)]);
  end;
  Result := FDistance;
end;
{--------}
function TaaTour.GetPossibleChange(var aUseRelocate : boolean;
                                   var aStartInx    : integer;
                                   var aEndInx      : integer;
                                   var aToInx       : integer) : double;
var
  Temp : integer;
  Inx1 : integer;
  Inx2 : integer;
  Inx3 : integer;
begin
  {first determine the type of change}
  aUseRelocate := Random < 0.5;
  {for a relocation...}
  if aUseRelocate then begin
    {generate three random indexes greater than 0}
    Inx1 := Random(pred(Count))+1;
    repeat
      Inx2 := Random(pred(Count))+1;
    until (Inx2 <> Inx1);
    repeat
      Inx3 := Random(pred(Count))+1;
    until (Inx3 <> Inx1) and (Inx3 <> Inx2);
    {sort them}
    if (Inx1 > Inx2) then begin
      Temp := Inx1; Inx1 := Inx2; Inx2 := Temp;
    end;
    if (Inx1 > Inx3) then begin
      Temp := Inx1; Inx1 := Inx3; Inx3 := Temp;
    end;
    if (Inx2 > Inx3) then begin
      Temp := Inx2; Inx2 := Inx3; Inx3 := Temp;
    end;
    {half the time make the insert point the first index, the other
     half make it the last one; calculate the difference in distance}
    Result := 0.0;
    if (Random < 0.5) then begin
      aToInx := Inx1;
      aStartInx := Inx2;
      aEndInx := Inx3;
      Result := Result - City[Inx1-1].Distance(City[Inx1])
                       + City[Inx1-1].Distance(City[Inx2])
                       - City[Inx2-1].Distance(City[Inx2])
                       + City[Inx3].Distance(City[Inx1]);
      if (Inx3 < pred(Count)) then
        Result := Result - City[Inx3].Distance(City[Inx3+1])
                         + City[Inx2-1].Distance(City[Inx3+1])
      else
        Result := Result - City[Inx3].Distance(City[0])
                         + City[Inx2-1].Distance(City[0])
    end
    else begin
      aStartInx := Inx1;
      aEndInx := Inx2;
      aToInx := Inx3;
      if (Inx3 = Inx2+1) then {there's no change}
        Exit;
      Result := Result - City[Inx1-1].Distance(City[Inx1])
                       - City[Inx2].Distance(City[Inx2+1])
                       - City[Inx3-1].Distance(City[Inx3]);
      Result := Result + City[Inx1-1].Distance(City[Inx2+1])
                       + City[Inx3-1].Distance(City[Inx1])
                       + City[Inx2].Distance(City[Inx3]);
    end;
  end
  {for a reversal...}
  else begin
    {generate two random indexes}
    Inx1 := Random(pred(Count))+1;
    repeat
      Inx2 := Random(pred(Count))+1;
    until (Inx2 <> Inx1);
    {sort them}
    if (Inx1 > Inx2) then begin
      Temp := Inx1; Inx1 := Inx2; Inx2 := Temp;
    end;
    {return the indexes}
    aStartInx := Inx1;
    aEndInx := Inx2;
    {now calculate the difference in distance}
    Result := 0.0;
    Result := Result - City[Inx1-1].Distance(City[Inx1])
                     + City[Inx1-1].Distance(City[Inx2]);
    if (Inx2 < pred(Count)) then
      Result := Result - City[Inx2].Distance(City[Inx2+1])
                       + City[Inx1].Distance(City[Inx2+1])
    else
      Result := Result - City[Inx2].Distance(City[0])
                       + City[Inx1].Distance(City[0])
  end;
end;
{--------}
procedure TaaTour.LoadFromFile(aName : string);
var
  F : text;
  X, Y : double;
begin
  System.Assign(F, aName);
  System.Reset(F);
  repeat
    readln(F, X, Y);
    FList.Add(TaaCity.Create(X, Y));
  until EOF(F);
  System.Close(F);
end;
{--------}
procedure TaaTour.Reverse(aStartInx, aEndInx : integer);
begin
  while (aStartInx < aEndInx) do begin
    FList.Exchange(aStartInx, aEndInx);
    inc(aStartInx);
    dec(aEndInx);
  end;
end;
{====================================================================}

{===TaaArticle=======================================================}
constructor TaaArticle.Create(aValue, aSize : double);
begin
  inherited Create;
  FValue := aValue;
  FSize := aSize;
end;
{--------}
constructor TaaArticle.CreateRandom;
begin
  inherited Create;
  FValue := Random * 100;
  FSize := Random * 100;
end;
{====================================================================}


{===TaaKnapsack======================================================}
constructor TaaKnapsack.Create(aSize : double);
begin
  inherited Create;
  FList := TList.Create;
  FSize := aSize;
end;
{--------}
destructor TaaKnapsack.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;
{--------}
procedure TaaKnapsack.AddArticle(aArticle : TaaArticle);
begin
  FList.Add(aArticle);
end;
{--------}
procedure TaaKnapsack.Assign(aKnapsack : TaaKnapsack);
var
  i : integer;
begin
  if (FList.Count = aKnapsack.FList.Count) then begin
    for i := 0 to pred(FList.Count) do
      FList[i] := aKnapsack.FList[i];
  end
  else begin
    FList.Clear;
    for i := 0 to pred(aKnapsack.Count) do
      FList.Add(aKnapsack[i]);
  end;
  FValue := aKnapsack.Value;
  {the above line will ensure that FFitCount and FFitSize are set
   properly}
  FFitCount := aKnapsack.FFitCount;
  FFitSize := aKnapsack.FFitSize;
end;
{--------}
function TaaKnapsack.GetArticle(aIndex : integer) : TaaArticle;
begin
  Result := FList[aIndex];
end;
{--------}
function TaaKnapsack.GetCount : integer;
begin
  Result := FList.Count;
end;
{--------}
function TaaKnapsack.GetValue : double;
var
  i        : integer;
  WorkSize : double;
  AllFit   : boolean;
begin
  if (FValue <= 0.0) then begin
    FValue := 0.0;
    WorkSize := 0.0;
    AllFit := true;
    for i := 0 to pred(FList.Count) do begin
      WorkSize := WorkSize + Article[i].Size;
      if (WorkSize <= Size) then
        FValue := FValue + Article[i].Value
      else {the last article didn't fit} begin
        AllFit := false;
        FFitSize := WorkSize - Article[i].Size;
        FFitCount := i;
        Break;
      end;
    end;
    if AllFit then begin
      FFitCount := FList.Count;
      FFitSize := WorkSize;
    end;
  end;
  Result := FValue;
end;
{--------}
procedure TaaKnapsack.GenerateChange;
var
  Inx1 : integer;
  Inx2 : integer;
begin
  {what we shall do is to swap a random article that fits in the
   knapsack with one that isn't there yet}
  Inx1 := Random(FitCount);
  Inx2 := Random(Count - FitCount) + FitCount;
  FList.Exchange(Inx1, Inx2);
  {ensure the value of the kanpsack gets recalculated at the earliest
   opportunity}
  FValue := 0.0;
end;
{--------}
procedure TaaKnapsack.LoadFromFile(aName : string);
var
  F : text;
  Value, Size : double;
begin
  System.Assign(F, aName);
  System.Reset(F);
  repeat
    readln(F, Value, Size);
    FList.Add(TaaArticle.Create(Value, Size));
  until EOF(F);
  System.Close(F);
end;
{====================================================================}


{===Helper routines==================================================}
procedure PrintKnapsack(const aMsg      : string;
                              aKnapsack : TaaKnapsack;
                              aLog      : TStream);
var
  i         : integer;
  LogString : string;
begin
  aLog.Write(aMsg[1], length(aMsg));
  LogString := ^M^J'   Value      Size'^M^J;
  aLog.Write(LogString[1], length(LogString));
  for i := 0 to pred(aKnapsack.Count) do begin
    if (i = aKnapsack.FitCount) then begin
      LogString := Format('--knapsack full-- (total size: %9.6f)'^M^J,
                          [aKnapsack.FitSize]);
      aLog.Write(LogString[1], length(LogString));
    end;
    LogString := Format('(%9.6f, %9.6f)'^M^J,
                        [aKnapsack.Article[i].Value,
                         aKnapsack.Article[i].Size]);
    aLog.Write(LogString[1], length(LogString));
  end;
end;
{--------}
procedure PrintTour(const aMsg  : string;
                          aTour : TaaTour;
                          aLog  : TStream);
var
  i         : integer;
  LogString : string;
begin
  aLog.Write(aMsg[1], length(aMsg));
  LogString := ^M^J;
  aLog.Write(LogString[1], length(LogString));
  for i := 0 to pred(aTour.Count) do begin
    LogString := Format('(%9.6f, %9.6f)'^M^J,
                        [aTour.City[i].X, aTour.City[i].Y]);
    aLog.Write(LogString[1], length(LogString));
  end;
end;
{====================================================================}


{===Interfaced Routines==============================================}
procedure TravelingSalesman(aCityCount : integer;
                            aLog       : TStream);
var
  i           : integer;
  MainTour    : TaaTour;
  BestTour    : TaaTour;
  LoopCount   : integer;
  Temp        : double;
  DeltaEnergy : double;
  LogString   : string;
  LowerCount, HigherCount : integer;
  UseRelocate : boolean;
  StartInx    : integer;
  EndInx      : integer;
  ToInx       : integer;
  StopCount   : integer;
begin
  StopCount := 10 * aCityCount;
  MainTour := nil;
  BestTour := nil;
  try
    {create the cities}
    MainTour := TaaTour.Create;
    (*
    MainTour.LoadFromFile('file1.txt');
    *)
    for i := 1 to aCityCount do
      MainTour.AddCity(TaaCity.CreateRandom);
    {write out the cities to the log file}
    PrintTour('Original city list', MainTour, aLog);
    {save this as the best tour so far}
    BestTour := TaaTour.Create;
    BestTour.Assign(MainTour);
    {set the temperature}
    Temp := 1000.0;
    LoopCount := 0;
    LowerCount := 0;
    HigherCount := 0;
    {continue until we freeze}
    LogString := ^M^J'Annealing beginning...'^M^J;
    aLog.Write(LogString[1], length(LogString));
    while (Temp > 0.002) do begin
      {this is one more loop}
      inc(LoopCount);
      {select a possible shuffling, get the change in distance}
      DeltaEnergy := MainTour.GetPossibleChange(UseRelocate,
                                                StartInx, EndInx,
                                                ToInx);
      {if we did better, save this tour as the best one so far}
      if (DeltaEnergy < 0.0) then begin
        MainTour.ApplyChange(UseRelocate,
                             StartInx, EndInx, ToInx, DeltaEnergy);
        BestTour.Assign(MainTour);
        inc(LowerCount);
      end
      {if we did worse, check Boltzmann's probability, and if our
       'coin toss' is less than this, use this as the best tour so
       far}
      else if (DeltaEnergy > 0.0) then begin
        if (Random < Exp(-DeltaEnergy/Temp)) then begin
          MainTour.ApplyChange(UseRelocate,
                               StartInx, EndInx, ToInx, DeltaEnergy);
          BestTour.Assign(MainTour);
          inc(HigherCount);
        end;
      end;
      {if we've done the required number of loops at this temperature,
       reduce the temperature by 1%}
      if (LoopCount >= StopCount) then begin
        LogString := Format('Temp=%.3f; TourDistance=%.3f; Lower=%d; Higher=%d'^M^J,
                            [Temp, BestTour.Distance, LowerCount, HigherCount]);
        aLog.Write(LogString[1], length(LogString));
        Temp := Temp * 0.99;
        LoopCount := 0;
        LowerCount := 0;
        HigherCount := 0;
      end;
    end;
    LogString := ^M^J'Annealing complete'^M^J;
    aLog.Write(LogString[1], length(LogString));
    PrintTour('--best tour', BestTour, aLog);
    LogString := Format('--best tour distance=%.3f'^M^J,
                        [BestTour.Distance]);
    aLog.Write(LogString[1], length(LogString));
  finally
    for i := 0 to pred(MainTour.Count) do
      MainTour.City[i].Free;
    MainTour.Free;
    BestTour.Free;
  end;
end;
{--------}
procedure SolveKnapsackProblem(aArticleCount : integer;
                               aLog          : TStream);
var
  i           : integer;
  MainSack    : TaaKnapsack;
  TestSack    : TaaKnapsack;
  BestSack    : TaaKnapsack;
  LoopCount   : integer;
  Temp        : double;
  DeltaEnergy : double;
  LogString   : string;
  LowerCount, HigherCount : integer;
  StopCount   : integer;
begin
  StopCount := 10 * aArticleCount;
  MainSack := nil;
  BestSack := nil;
  TestSack := nil;
  try
    {create a knapsack and the articles; set the size of the knapsack
     so that about 1/10 of the articles will fit}
    MainSack := TaaKnapsack.Create(aArticleCount * 5.0);
    for i := 1 to aArticleCount do
      MainSack.AddArticle(TaaArticle.CreateRandom);
    {save this as the best packing so far}
    BestSack := TaaKnapsack.Create(aArticleCount * 5.0);
    BestSack.Assign(MainSack);
    {create the test sack}
    TestSack := TaaKnapsack.Create(aArticleCount * 5.0);
    {write out the articles to the log file}
    PrintKnapsack('Original article list', MainSack, aLog);
    {set the temperature}
    Temp := 500.0;
    LoopCount := 0;
    LowerCount := 0;
    HigherCount := 0;
    {continue until the temperature is just above freezing}
    LogString := ^M^J'Annealing beginning...'^M^J;
    aLog.Write(LogString[1], length(LogString));
    while (Temp > 0.002) do begin
      {this is one more loop}
      inc(LoopCount);
      {select a possible shuffling, get the change in value}
      TestSack.Assign(MainSack);
      TestSack.GenerateChange;
      DeltaEnergy := MainSack.Value - TestSack.Value;
      {if we did better, save this packing as the best one so far}
      if (DeltaEnergy < 0.0) then begin
        MainSack.Assign(TestSack);
        BestSack.Assign(MainSack);
        inc(LowerCount);
      end
      {if we did worse, check Boltzmann's probability, and if our
       'coin toss' is less than this, use this as the best tour so
       far}
      else if (DeltaEnergy > 0.0) then begin
        if (Random < Exp(-DeltaEnergy/Temp)) then begin
          MainSack.Assign(TestSack);
          BestSack.Assign(MainSack);
          inc(HigherCount);
        end;
      end;
      {if we've done the required number of loops at this temperature,
       reduce the temperature by 1%}
      if (LoopCount >= StopCount) then begin
        LogString := Format('Temp=%.3f; Knapsack value=%.3f; Lower=%d; Higher=%d'^M^J,
                            [Temp, BestSack.Value, LowerCount, HigherCount]);
        aLog.Write(LogString[1], length(LogString));
        Temp := Temp * 0.99;
        LoopCount := 0;
        LowerCount := 0;
        HigherCount := 0;
      end;
    end;
    LogString := ^M^J'Annealing complete'^M^J;
    aLog.Write(LogString[1], length(LogString));
    PrintKnapsack('--best packing', BestSack, aLog);
    LogString := Format('--best packing value=%.3f'^M^J,
                        [BestSack.Value]);
    aLog.Write(LogString[1], length(LogString));
  finally
    for i := 0 to pred(MainSack.Count) do
      MainSack.Article[i].Free;
    MainSack.Free;
    BestSack.Free;
    TestSack.Free;
  end;
end;
{====================================================================}

end.